home *** CD-ROM | disk | FTP | other *** search
FORTH Source | 1992-06-01 | 16.3 KB | 708 lines |
-
- \ TracePFA ( pfa -- ) analyze word, mark as referenced. If word
- \ calls others, recursively analyze ALL SUB-words until all are known.
-
- decimal
-
- only forth definitions
-
- ANEW TASK-TREE.F
-
- .need CFATable>
- defer CFATable> ' noop is CFATable>
- .then
-
-
- variable Tracking \ user turns this on for mem & file allocation tracking
- \ in his target image
-
- variable NoConsole \ if true, clone dummy code for
- \ KEY, EMIT, ?TERMINAL
-
- \ variable NoAmiga \ Don't include Amiga startupcode...
- \ The "main" ap can load the executable in and
- \ CALL it
-
- global-defer FreeOverlay ' drop is FreeOverlay
-
- variable CloneOverlay \ if true, save 'References' -> MasterRef when CLONE done
-
- also TGT definitions
-
-
- \ Record-keeping Stacks ... entries made for each referenced pfa...
-
-
- 0 DynamicStack References \ Sorted stack of called addresses...
- 0 DynamicStack RefPackets \ 'References' index also index for here...
- \ index holds address of 'Packet', described below.
-
- 0 DynamicStack MasterRefs \ holds references for 'master' program
- 0 DynamicStack MasterRefPackets \ ref packets for 'master'
- variable CloneInputCFA \ CFA of word passed to CLONE command
- variable OverlaysDefined
-
- 128 DynamicStack Substitutes \ so 'FIND' doesn't run so much
- 128 DynamicStack SubCFAs
-
- EXISTS? status? .IF
- : NumRefs ReferencesBase freecell ; ' numrefs is #Cloned
- .THEN
-
- : FreeMaster ( -- )
- MasterRefsVAR FreeStack
- MasterRefPacketsVAR @&FreeBlocks
- ;
-
- also forth definitions
-
- variable KeepMaster
-
- : InitClone
- CloneOverLay @
- IF
- MasterRefsVAR @ 0=
- IF
- ReferencesVAR @
- IF
- ReferencesBASE MasterRefsVAR !
- RefPacketsBASE MasterRefPacketsVAR !
- ReferencesVAR off
- RefPacketsVAR off
- >newline ." Ready to CLONE overlays" cr
- THEN
- ELSE
- KeepMaster @
- IF
- false
- ELSE
- >newline ." Finished CLONE-ing overlays?" Y/N
- THEN
- IF
- FreeMaster
- ' drop is FreeOverlay OverlaysDefined off
- CloneOverLay off
- THEN
- THEN
- ELSE
- MasterRefsVAR @
- IF
- FreeMaster
- THEN
- THEN
- ReferencesVAR FreeStack
- RefPacketsVAR @&FreeBlocks
- SubstitutesVAR FreeStack
- SubCFAsVAR FreeStack
- InitClone
- KeepMaster off
- ;
-
- : NewOverlay ( -- )
- KeepMaster on
- " INITCLONE" find
- IF
- execute
- ELSE
- KeepMaster off >newline " Can't FIND 'INITCLONE'" $error
- THEN
- ;
-
- previous definitions
-
-
- variable CFABase \ holds CFA of word we ate tracing or cloning...
-
- \ and a sample-definition...
-
- \ Global-Defer Sample-Defer ' (pushadr) is Sample-Defer
-
- : Sample-Defer (pushadr) @execute ; $ 4e75 w, ' (pushadr) ,
-
-
- \ RefPacket definition and handlers ...
-
-
- :struct RefPacket
- ubyte Ref_IsPFA \ it non-zero, called address IS a legal pfa.
- ubyte Ref_Resolved \ true if defined in the targetimage.
- ulong Ref_#Times \ #times this PFA is called
- ulong Ref_TgtAdr \ Target relative resolved address
- ;struct
-
-
- \ This is a foolproof method for figuring how much space exists from
- \ a given location to the following NFA.
-
-
- variable StartArea variable MinDiff
-
-
- .NEED asm
- : ClosestNFA? ( nfa -- ) dup startarea @ >=
- IF
- startarea @ - mindiff @ min mindiff !
- ELSE
- drop
- THEN
- ;
- .ELSE
- asm ClosestNFA? ( nfa -- )
- move.l #[StartArea],a0 never do this, since this code
- cmp.l 0(org,a0.l),tos will never clone, it's ok here
- blt 1$
- move.l #[MinDiff],a1 a0=StartArea
- add.l org,a1 a1=MinDiff(abs)
- sub.l 0(org,a0.l),tos
- cmp.l (a1),tos
- bge 1$
- move.l tos,(a1)
- 1$: move.l (dsp)+,tos
- end-code
- .THEN
-
- .NEED asm
- : ClosestVOC? ( voc-link -- )
- vlink>' >name ClosestNFA?
- ;
- .ELSE
- asm ClosestVOC? ( voc-link -- )
- subq.l #8,tos
- callcfa >name
- callcfa ClosestNFA?
- end-code
- .THEN
-
- : NextLFA ( ?addr -- next-LFA-above )
- StartArea ! [ -1 u2/ ] literal mindiff !
- ' ClosestNFA? is when-scanned
- ' ClosestVOC? is when-voc-scanned scan-all-vocs
- mindiff @ [ -1 u2/ ] literal =
- IF
- here StartArea @ - 0 max mindiff !
- ELSE
- -4 mindiff +!
- THEN
- StartArea @ mindiff @ +
- ;
-
- : <ValPFA?> ( 0 pfa -- flag dummy )
- ;
-
- : ValidPFA? ( pfa -- flag )
- 0 swap
- dup cell- @ $ 0070,f800 and 0= ( -- 0 pfa flag )
- IF
- \ a rational size code exists...
- dup >name dup Valid-Name? ( -- 0 pfa nfa? flag )
- IF
- \ the name-field seems to make sense...
- name> over = ( -- 0 pfa flag )
- IF
- \ going back to the pfa gives the original adr, it's good!
- 2drop true dup
- THEN
- ELSE
- drop
- THEN
- THEN
- drop
- ;
-
- : >CFA ( adr? -- cfa )
- BEGIN
- dup ValidPFA? 0=
- WHILE
- 2-
- REPEAT
- ;
-
- : IsValuePFA? ( pfa? -- flag )
- dup validpfa? dup ( -- adr flag flag )
- IF
- drop dup cell- @ $ f,0000 and VALUE_ID =
- THEN
- swap drop
- ;
-
- 0 .IF
- defer JustForParent ' justforParent >parent
- forget JustForParent
- constant DeferParent
- .THEN
-
- : GETNAME ( cfa -- , move fullname to HERE )
- >name dup c@ $ 1f and dup >r 1+ ( -- nfa count+1 )
- here swap move r> here c!
- ;
-
-
- : SUBSTITUTE? ( cfa -- cfa' )
- dup CloneInputCFA @ = CloneOverlay @ AND ?exit
- \
- dup >r dup ValidPFA?
- IF
- dup Substitutes StackFind ( -- cfa index flag ) 2dup 2 x>r
- ( -r- cfa flag index )
- IF
- SubCFAsBASE stack@ ( -- cfa newcfa )
- dup ' Redefs ' RedefsEnd within? ( -- cfa newcfa flag )
- IF
- drop true
- ELSE
- nip false
- THEN
- ELSE
- drop true
- THEN ( -- cfa? flag )
- IF
- 1 rpick 0=
- IF
- dup r@ ( -- cfa cfa ix ) Substitutes StackInsert
- THEN
- dup GETNAME
- \
- NoConsole @
- IF
- only IORedefs definitions here find
- IF
- dup CFABase @ -
- IF
- ( -- cfa cfa2 ) swap
- THEN
- THEN
- only forth definitions drop
- THEN
- \
- dup 2 rpick = ( not found in redefs )
- Tracking @ 0= and ( notracking wanted )
- IF
- only AllocRedefs definitions here find
- IF
- dup CFABase @ -
- IF
- ( -- cfa cfa2 ) swap
- THEN
- THEN
- only forth definitions drop
- THEN
- dup 2 rpick = ( still not found )
- [ 1 .if ]
- IF
- only redefs definitions here find
- IF
- dup CFABase @ -
- IF
- ( -- cfa cfa2 ) swap
- THEN
- THEN
- only forth definitions drop
- THEN
- [ .else ]
- NoConsole @ and
- IF
- only IORedefs definitions here find
- IF
- dup CFABase @ -
- IF
- ( -- cfa cfa2 ) swap
- THEN
- THEN
- only forth definitions drop
- THEN
- [ .then ]
- \
- 1 rpick 0=
- IF
- dup r@ ( -- cfa2 cfa2 ix ) SubCFAs StackInsert
- THEN
- THEN
- 2 xrdrop
- THEN
- rdrop
- ;
-
-
- : <CreatePacket> ( pfa index -- address ) >r
- MEMF_CLEAR sizeof() RefPacket allocblock? ( -- pfa pktadr )
- dup r> RefPackets StackInsert ( -- pfa pktadr )
- swap ValidPFA? over ..! Ref_IsPFA ( -- pktadr )
- ;
-
-
- : <CreateReference> ( pfa index -- packetaddr )
- 2dup References StackInsert ( -- pfa index ) <CreatePacket>
- ;
-
-
- variable IfCreateRefs Global-Defer TrapPacket
- variable InMaster
-
- : PacketFor ( pfa -- Packet-Base )
- InMaster off
- MasterRefsVAR @
- IF
- dup MasterRefs StackFind ( -- pfa index flag )
- dup InMaster !
- ELSE
- 0 0
- THEN
- IF
- cells MasterRefPacketsBase + @ ( -- pfa pktaddr ) nip
- ELSE
- drop
- dup References StackFind ( -- pfa index flag )
- IF
- \ it exists...
- cells RefPacketsBase + @ ( -- pfa pktaddr )
- ELSE
- IfCreateRefs @
- IF
- \ 1st time referenced ...
- <CreateReference> dup ( -- pktadr pktadr )
- ELSE
- \ error...shouldn't be extending ref tables...
- ( -- pfa pktaddr ) TrapPacket quit
- THEN
- THEN
- nip
- THEN
- ;
-
- : CFA>Tgt ( dictcfa -- tgtadr )
- PacketFor dup ..@ ref_Resolved ( -- packet flag )
- IF
- ..@ ref_TgtAdr
- ELSE
- \
- \ not built in target yet...
- \
- >newline
- ." DICT>TGT: " >name ID. ." referenced but not built" quit
- THEN
- ;
-
- : Dict>TGT ( dictadr -- tgtaddr , call only after everthing built! )
- dup ValidPFA?
- IF
- \
- \ the address IS a cfa
- CFA>Tgt
- ELSE
- dup defer-size - ' emit defer-size compare 0=
- IF
- ( defered ) defer-size - CFA>Tgt defer-size +
- ELSE
- \
- \ assume it's referencing some CREATE DOES> child...
- \
- ( -- dictadr ) dup >CFA
- ( -- dictadr it's-cfa ) dup cell- @ $ f,0000 and
- CASE
- VARIABLE_ID of
- dup [ Tracking ' Tracking - ] literal +
- ( -- dictadr cfa cfa+data ) 2 pick - endof
- CREATE_ID of
- 2dup - endof
- >newline over
- ." DICT>TGT: address within " >name ID.
- ." can't be derived" quit
- ENDCASE
- ( -- dictadr cfa diff-from-tgt-adr ) swap
- PacketFor ( -- dictadr diff pkt ) ..@ ref_TgtAdr + nip
- THEN
- THEN
- ;
-
-
- 0 .IF
- : CreateDoes? ( adr -- ??_ID , return ID code if not a colon def )
- \
- \ Check if the SFA has a special_ID marked in the SFA...
- \
- dup PacketFor ..@ ref_IsPFA dup
- IF
- drop dup cell- @ $ f,0000 and
- THEN
- swap drop
- ;
- .THEN
-
-
- \ the word that cycles thru a PFA...
-
- .need myself
-
- : MYSELF ( -- , compile self )
- latest name> calladr,
- ; IMMEDIATE
-
- .then
-
-
- : CallingLibOpen? ( opadr -- flag )
- 0 >r dup @ $ 2d07,2e3c =
- IF
- dup 16 + Calls?
- IF
- ' LibOpen? =
- IF
- rdrop true >r
- THEN
- THEN
- THEN
- drop r>
- ;
-
- defer DoTracePFA
-
- : TraceIVs ( class-cfa -- )
- dup >LastIvar @ ( -- classCFA lastivar )
- BEGIN
- ?dup
- WHILE
- ( classCFA lastivar ) do-does-size - dup
- ( classCFA insobjcfa insobjcfa ) >IvarClass @ do-does-size - recurse
- >PrevIvar @
- REPEAT
- ( class-cfa -- ) DoTracePFA
- ;
-
- : CheckIf:Class ( cfa -- )
- dup cell- @ :CLASS_BIT and
- IF
- \ it's an ODE :CLASS!
- \
- dup >CFATable ( -- cfa &cfa's )
- dup >#Methods 0
- DO
- dup @ DoTracePFA cell+
- LOOP
- drop ( -- cfa )
- \
- \
- [ 0 .if ]
- dup do-does-size + @ ( -- xxx &cfa's ) CFATable> TraceIVs
- [ .else ]
- dup >LastIvar @
- BEGIN
- ?dup
- WHILE
- do-does-size - dup DoTracePFA
- dup >IvarClass @ do-does-size - DoTracePFA
- >PrevIvar @
- REPEAT
- [ .then ]
- \
- \
- THEN
- drop
- ;
-
- : CheckIfClass ( cfa -- )
- dup PacketFor ..@ ref_IsPFA \ ValidPFA?
- IF
- dup cell- @ CLASS_BIT and
- IF
- \ it's an ODE CLASS!
- \
- \
- \
- [ 0 .if ]
- dup do-does-size + @ ( -- xxx &cfa's )
- dup >#Methods 0
- DO
- dup @ DoTracePFA cell+
- LOOP
- drop
- [ .else ]
- dup do-does-size + @ ( -- xxx &cfa's ) CFATable> TraceIVs
- [ .then ]
- \
- \
- ELSE
- dup CheckIf:Class
- THEN
- THEN
- drop
- ;
-
- : PCRel>Dest ( &pcrel-opcode -- reldestadr )
- 2+ dup w@ w->s +
- ;
-
- : Dest>PCRel ( reldestadr opcode-adr -- rel-offset )
- - 2-
- ;
-
-
- variable do?pause
- variable TrapOn
-
- : TracePFA ( pfa -- ) \ ?pause
- TrapOn @
- IF
- dup TrapOn @ =
- IF
- cr ." TRAPPED: " TrapOn @ .hex
- ." , CfaBase = " CFABASE @ .hex quit
- THEN
- THEN
- \ x ) dbgon >newline cr cr cr dbgoff
- Status?
- IfCreateRefs on
- \ x ) dbgon >newline ." TracePFA: before Substitute?" .s >newline dbgoff
- Substitute?
- \ x ) dbgon >newline ." TracePFA: after Substitute?: " .s >newline dbgoff
- CFABase @ swap dup CFABase !
- dup IsValuePFA? 0=
- over references stackfind nip 0= and
- MasterRefsVAR @
- IF
- over MasterRefs StackFind ( -- pfa flag index flag ) nip 0= and
- THEN
- >r
- \
- \ Get or create the 'packet' for this pfa...
- \
- dup PacketFor ( -- pfa packet )
- \ x ) dbgon >newline ." TracePFA: after PacketFor: " .s >newline dbgoff
- \
- \ if vectored, pull up executable contents
- \
- dup ..@ ref_IsPFA
- IF
- over cell- @ $ f,0000 and dup USERDEF_ID = swap GLOBDEF_ID = or
- IF
- \ x ) dbgon >newline ." TracePFA: recursing on defer" .s >newline dbgoff
- over >is @ myself
- \ x ) dbgon >newline ." TracePFA: done recursing" .s >newline dbgoff
- THEN
- THEN
- \
- \ register the fact that its being called...
- \
- dup ..@ ref_#times 1+ over ..! ref_#times r>
- IF
- \
- \ start the loop checking for more references
- \
- >r 0 >r ( -- opadr ) ( -r- packetadr hibra )
- dup CheckIfClass
- BEGIN
- do?pause @ IF ?pause THEN
- dup w@ $ 4e75 - r@ or
- WHILE
- \ x ) dbgon >newline ." TracePFA: not RTS: " dup .hex .s >newline dbgoff
- dup Calls?
- IF
- ( -- opadr calledadr ) myself
- ELSE
- dup ALit?
- IF
- \ ( -- opadr ref'd-addr ) check if a create/does
- dup 2- w@ $ 4e75 = >r
- dup do-does-size -
- dup cell- @ $ f,0000 and $ 1,0000 $ 6,0000 within? >r
- ValidPFA? r> and r> and
- IF
- \ x ) dbgon >newline ." TracePFA: recursing, alit do-does" .s >newline dbgoff
- do-does-size - myself \ some kind of data word
- \ x ) dbgon >newline ." TracePFA: done recursing, alit do-does" .s >newline dbgoff
- ELSE
- dup ValidPFA?
- IF
- \ x ) dbgon >newline ." TracePFA: recursing, alit cfa" .s >newline dbgoff
- myself
- \ x ) dbgon >newline ." TracePFA: done recursing, alit cfa" .s >newline dbgoff
- ELSE
- \ x ) dbgon >newline ." TracePFA: recursing, Alit data" .s >newline dbgoff
- \ is pointing to some kind of data area (ARRAY?)
- >CFA myself
- \ x ) dbgon >newline ." TracePFA: done recursing, alit data" .s >newline dbgoff
- THEN
- THEN
- ELSE
- dup w@ dup PCRel? swap 1 and 0= and ( can't calc x(pc,??)
- IF
- \ extract addr
- dup PCRel>Dest dup ValidPFA?
- IF
- \ x ) dbgon >newline ." TracePFA: recursing, pcrel cfa" .s >newline dbgoff
- myself
- \ x ) dbgon >newline ." TracePFA: done recursing, pcrel cfa" .s >newline dbgoff
- ELSE
- \ x ) dbgon >newline ." TracePFA: recursing, pcrel data" .s >newline dbgoff
- \ is pointing to some kind of data area (ARRAY?)
- >CFA myself
- \ x ) dbgon >newline ." TracePFA: done recursing, pcrel data" .s >newline dbgoff
- THEN
- THEN
- THEN
- THEN
- dup CallingLibOpen?
- IF
- 18 +
- ELSE
- dup w@ >r dup +NextOp ( -- opadr opsize ) ( -r- hibra opc )
- over + swap ( -- nextopa opadr )
- r> dup BranchOp? ( -- nextadr opadr opcode flag )
- IF
- BRAto? dup r@ > ( -- nextadr dest replaceflag )
- IF
- dup r> drop >r
- THEN
- drop ( -- nextadr )
- ELSE
- 2drop
- THEN
- r@ -dup
- IF
- ( -- nextadr hibra )
- over <=
- IF
- r> drop 0 >r
- THEN
- THEN
- THEN
- REPEAT
- r> 2drop r> drop
- ELSE
- 2drop
- THEN
- CFABase !
- ;
- ' tracepfa is dotracepfa
-
- : .Refs ( -- , show contents of stacks )
- cr base @ >r
- ReferencesBase freecell dup . ." PFAs referenced ..." cr ?dup
- IF
- 0
- DO
- i cells ReferencesBase + @ ( -- pfa )
- hex dup 9 .r space
- dup packetfor dup ..@ ref_ISPFA
- IF over >name id.
- ELSE ." -- No NFA --"
- THEN space ascii . 30 emit-to-column space
- swap drop ( -- packet )
- ..@ ref_#times decimal 3 .r ." times" flushemit ?pause cr
- LOOP
- THEN
- r> base !
- ;
-
-
- : ShowCalls ( -- , <name> )
- ReferencesVAR FreeStack
- RefPacketsVAR @&FreeBlocks
- [compile] ' TracePFA
- .refs
- ;
-
-
- only forth definitions
- also TGT
-
-